home *** CD-ROM | disk | FTP | other *** search
/ BMUG Revelations / BMUG Revelations.toast / Programming / Programming Languages / Yerk 3.64 / Toolbox Classes / QD1 < prev    next >
Encoding:
Text File  |  1993-05-14  |  4.7 KB  |  184 lines  |  [TEXT/YERK]
  1. \ qd1 - more QuickDraw objects
  2. \ 12/14/84  cbd Version 1
  3. \ 11/16/85  cdn Added disp: method to Picture & Icon
  4. \  8/31/88    rfl added theClip to this source
  5. \  8/14/90    rfl moveto fixed
  6. \  4/11/92    rfl    added putResId: as alias for init:
  7. \  5/13/94    rfl    protected getnew:'s
  8. Decimal
  9.  
  10. rect theClip    \ global clip rectangle
  11. -1000 dup 1000 dup put: theClip
  12.  
  13. : +pair { x1 y1 x2 y2 -- x1+y1 x2+y2 } x1 x2 + y1 y2 + ;
  14.  
  15. \ Interface object for QD picture support
  16. :CLASS Picture  <Super Object
  17.  
  18.     Handle    picHndl
  19.     Int        resID        \ resource ID if it is a resource
  20.     Rect    DestRect    \ destination rectangle for drawing
  21.  
  22.     \ ( l t r b -- )  Open a new pict with given frame
  23.     :M  OPEN:  Put: destrect  0 abs: destrect call OpenPicture
  24.         Put: picHndl  ;M
  25.  
  26.     \ ( -- )  terminate this picture definition
  27.     :M  CLOSE:  call ClosePicture   ;M
  28.  
  29.     \ ( resID -- )
  30.     :M INIT:  put:  resID  ;M
  31.  
  32.     :M PUTRESID: put: resID ;M
  33.  
  34.     \ load the picture from a resource file
  35.     :M  GETNEW:  0 int: resID  call GetPicture dup 0= classerr" 170 put: picHndl
  36.         ptr: picHndl  2+ get: rect  put: destRect   ;M
  37.  
  38.     \ ( w h -- )  Set size in pixels of dest rect
  39.     :M  SIZE:   getTop:  destRect  +Pair  putBot: destRect ;M
  40.  
  41.     \ ( x y -- )  Move dest rect to given location
  42.     :M  GOTO:  { x y -- }   Size: destRect  x y putTop: DestRect
  43.         Size: self  ;M
  44.  
  45.     \ ( -- )  Draw the picture in destRect
  46.     :M  DRAW:  get: picHndl abs: destRect
  47.         call DrawPicture   ;M
  48.  
  49.     \ ( x y resID -- )  Combines the actions of init:, getNew:, goto: & draw:
  50.     :M  DISP:  putResID: self  getNew: self  goto: self  draw: self  ;M
  51.  
  52.     \ goto to location and draw self
  53.     :M  MOVETO: ( x y -- ) goto: self draw: self ;M
  54.  
  55.     \ ( -- )  dispose of picture heap
  56.     :M  KILL:  get: picHndl  call KillPicture   ;M
  57.  
  58. ;CLASS
  59.  
  60. \ resource-based Icon
  61.  
  62. :CLASS Icon  <Super Object
  63.  
  64.     Handle    theHandle
  65.     Int        resID
  66.     Rect    theRect
  67.  
  68.     \ ( resID -- )  set the resource ID
  69.     :M  INIT:  put: resID    ;M
  70.  
  71.     \ load the icon from a resource file
  72.     :M  GETNEW:   0 int: resID  call GetIcon  dup 0= classerr" 170 put: theHandle  ;M
  73.  
  74.     \ ( x y -- )  move topLeft corner to x,y
  75.     :M  GOTO:  { x y -- }  x y  x 32 + y 32 +  put: theRect  ;M
  76.  
  77.     \ draw the icon at current location
  78.     :M  DRAW:  abs: theRect  get: theHandle  call PlotIcon  ;M
  79.  
  80.     \ ( x y resID -- )  Combines the actions of init:, getNew:, goto: & draw:
  81.     :M  DISP:  init: self  getNew: self  goto: self  draw: self ;M
  82.  
  83. ;CLASS
  84.  
  85. \ define the quickDraw bitmap object
  86. :CLASS qdBitMap  <Super Object
  87.  
  88.     Var        BaseAddr
  89.     Int        RowBytes
  90.     Rect    BndsRect
  91.  
  92.     \ ( addr n  l t r b -- )
  93.     :M  PUT:   Put:  bndsRect  Put: RowBytes
  94.         Put: BaseAddr  ;M
  95.  
  96. ;CLASS
  97.  
  98. \ rounded rectangle
  99. :CLASS RndRect  <Super Rect
  100.  
  101.     Point    ovalSize    \ size in pixels of ovals at corners
  102.  
  103.     \ ( w h -- )  set width, height of corners
  104.     :M  INIT:  put: ovalSize  ;M
  105.  
  106.     \  ( -- )
  107.     :M  DRAW:  (abs) int: ovalSize call FrameRoundRect  ;M
  108.  
  109.     :M  PRINT:  Draw:  Self  ;M
  110.  
  111.     :M  CLEAR:  (abs) int: ovalSIze  call EraseRoundRect   ;M
  112.  
  113.     \ ( ^patObj -- )  Fill rect with pattern )
  114.     :M  FILL:  { pat -- }
  115.         (abs) int: ovalSize  pat +base  call FillRoundRect   ;M
  116.  
  117.     \ ( -- x y )
  118.     :M  CENTER:   { \ x y -- }  Size: Self  2/  -> y  2/ -> x
  119.         GetX: TopL  x +    getY: topL y +   ;M
  120.  
  121.     \ ( -- )
  122.     :M  INVERT: (abs) int: ovalSize call InverRoundRect ;M
  123.  
  124.     \ ( -- )
  125.     :M  PAINT:  (abs) int: ovalSize call PaintRoundRect ;M
  126.  
  127. ;CLASS
  128.  
  129. \ QuickDraw ovals - data is same as a Rect
  130. :CLASS Oval  <Super Rect
  131.  
  132.     \ ( -- )
  133.     :M  DRAW:  (abs) call FrameOval   ;M
  134.  
  135.     \ ( -- )
  136.     :M  CLEAR:  (abs) call EraseOval  ;M
  137.  
  138.     \ ( -- )
  139.     :M  PAINT:  (abs) call PaintOval  ;M
  140.  
  141.     :M  FILL:  { pat -- }  (abs) pat +base call FillOval   ;M
  142.  
  143.     :M  INVERT:  (abs) call InvertOval  ;M
  144.  
  145. ;CLASS
  146.  
  147. \ Variable-length image object for bit images
  148. \  E.G., an Icon would have 32 cells, rowbytes=4
  149. :CLASS Image  <Super Array
  150.  
  151.     Var        BaseAddr
  152.     Int        RowBytes    \ Source bitMap
  153.     Rect    bndsRect
  154.     Var        DestBits    \ addr of destination bit image
  155.     Int        Mode
  156.     Rect    Destrect    \ Destination rect for CopyBits
  157.  
  158.     \ ( -- )  Set the source, destination bitmap ptrs
  159.     :M  GETPORT:  Abs: DestBits  call GetPort 2 +: DestBits
  160.         0  ^elem: self   +base  Put: baseAddr   ;M
  161.  
  162.     \ ( mode rowBytes topX topY -- )
  163.     :M  INIT:  { themode rBytes topX topY -- }  themode Put: mode
  164.         rBytes Put: RowBytes topX topY PutTop: bndsRect
  165.         rBytes 8 * topX +    \ # of bits in a row + topX
  166.         limit: self  width: self * rBytes / topY +    \ # of rows + topy
  167.         PutBot: bndsRect
  168.         GetPort: Self   ;M
  169.  
  170.     \ ( x  y -- )  Move location without drawing
  171.     :M  GOTO:  { xloc yloc -- }  xloc  yloc Puttop: DestRect
  172.         size: bndsRect  xloc yloc +Pair  PutBot: destRect   ;M
  173.  
  174.     \ ( -- )  Draw the image at its current location
  175.     :M  DRAW:    (abs)  Get: DestBits  Abs: bndsRect  Abs: DestRect
  176.         Int: Mode  0 call CopyBits  ;M
  177.  
  178.     \ ( x y -- )  Goto a location and draw the image
  179.     :M  MOVETO:  Goto: Self Draw: Self   ;M
  180.  
  181.     :M  CLASSINIT: srcXor 2 0 0  Init: Self 0 0 Goto: self ;M
  182.  
  183. ;CLASS
  184.